perm filename SPOT.SAI[11,ALS] blob
sn#073870 filedate 1973-11-29 generic text, type T, neo UTF8
00010 BEGIN "PLOT"
00020 DEFINE ⊂="COMMENT"; ⊂ NOV.26,1973;
00030 ⊂ Modified to use pulse markers and to permit their motion;
00040 DEFINE ⊃="⊂";
00050 DEFINE CR="'15",LF="'12",CRLF="CR&LF",TB="'11";
00060 REQUIRE "DPYSUB.HDR[1,PDQ]" SOURCE_FILE;
00070 LABEL STARTP,STOPP,TOFORM;
00080 ⊂ DEFINE \=" "; DEFINE \="SAFE"; ⊂ Alternarte definitions;
00090 ⊂ REQUIRE "LPC2[X,ALS]" LOAD_MODULE;
00100 FORTRAN REAL PROCEDURE SQRT(REAL X);
00110 FORTRAN REAL PROCEDURE ALOG10(REAL X);
00120 FORTRAN REAL PROCEDURE COS(REAL X);
00130 FORTRAN REAL PROCEDURE SIN(REAL X);
00140 INTEGER ZEROC,ZEROF,DX;
00150 ⊂ EXTERNAL FORTRAN PROCEDURE LPC1(REFERENCE REAL A,B,R0,C;⊂ REFERENCE INTEGER N,I,J);
00160 REQUIRE "FFT8X[X,ALS]" LOAD_MODULE;
00170 EXTERNAL FORTRAN PROCEDURE FRXFM
00180 (REFERENCE INTEGER M;REFERENCE REAL X,Y);
00190 \ INTERNAL REAL ARRAY A,B,C,D[0:512];
00200 REAL X,SX; \ REAL ARRAY WINDOW[0:512];
00210 INTERNAL REAL R0;
00220 INTEGER LPCOPT;
00230 \ INTEGER ARRAY DPYBUF[0:2047];
00240 \ INTEGER ARRAY LFILE[0:'177];
00250 \ INTEGER ARRAY SYMBOL[0:127];
00260 \ INTEGER ARRAY DAT,AVDAT[0:23];
00270 \ INTEGER ARRAY FVAL[0:8];
00275 INTEGER FVAL1,FVAL2;
00280 INTEGER FX,SEGCS;
00290 STRING ARRAY SAMPLE[0:127];
00300 INTEGER I,J,K,L,P,PP,Q,QQ,R,DK,DDK,DDDK,DVAL,DDVAL,DDDVAL,
00310 POINTX,STATE,DELTA,VAL,CHAN1,EOF,POINTT,POINTV;
00320 INTERNAL INTEGER M,N;
00330 INTEGER PT0,PT1,PT2,X0,X1,Y0,Y1,X2,Y2,WFLAG,
00340 PTCNT,PICK,JP,JPX,OPT,OPT1,SHUFCT;
00350 INTEGER II,JJ,KK,NN,SEGC,BRK,EOFA,EOFT,EOFTF,READ3,
00360 SEGTOT,SEGIN,IIT,JJT,KKT,NNT,ITT,JTT,KTT,SEGCT;
00370 BOOLEAN ER;
00380 INTEGER CHAN2,CHAN3,CHAN4,CHAN5,CHAN6,CHANX;
00390 \ INTEGER ARRAY BUF,BUFT,BUFTT[0:511];
00400 STRING FILEN,READ,READ1,READT,READTT,FILEO,READ2,FILEQ,TFILE,FILLST;
00410
00420 PROCEDURE OUTALL(STRING S);
00430 BEGIN
00440 STRING SS; INTEGER J;
00450 SETBREAK(18,0,NULL,"OSN");
00460 SS←SCAN(S,18,J);
00470 OUTSTR(SS);
00480 END;
00490
00500 PROCEDURE DATAIN;
00510 BEGIN
00520 INTEGER J;
00530 FOR J←0 STEP 1 UNTIL 511 DO BUF[J]←0;
00540 IF EOF=0 THEN ARRYIN(CHAN1,BUF[0],512)
00550 ELSE OUTSTR
00560 ("No more data with JJ= "&CVS(JJ)&"SEGC= "&CVS(SEGC)&CRLF);
00570 POINTX←POINT(12,BUF[0],-1);
00580 SEGC←II←II+12; JJ←II+11;
00590 END;
00600
00610 PROCEDURE DATTIN;
00620 BEGIN
00630 INTEGER J;
00640 FOR J←0 STEP 1 UNTIL 511 DO BUFT[J]←0;
00650 IF EOFA=0 THEN ARRYIN(CHAN2,BUFT[0],512)
00660 ELSE OUTSTR
00670 ("No more T0X data with JJ= "&CVS(JJ)&"SEGC= "&CVS(SEGC)&CRLF);
00680 POINTT←POINT(6,BUFT[0],-1);
00690 SEGCT←IIT←IIT+128; JJT←IIT+127;
00700 END;
00710
00720 PROCEDURE DTTTIN;
00730 BEGIN
00740 INTEGER J;
00750 IF EOFT=0 THEN ARRYIN(CHAN3,BUFTT[0],512)
00760 ELSE OUTSTR
00770 ("No more .P data with JJ= "&CVS(JJ)&"SEGC= "&CVS(SEGC)&CRLF);
00780 FOR J←0 STEP 1 UNTIL 511 DO IF BUFTT[J]=0 THEN BUFTT[J]←'377777777777;
00790 ITT←BUFTT[0] LSH -15; KTT←0; JTT←BUFTT[511] LSH -15;
00800 ⊂ FOR J←0 STEP 1 UNTIL 10 DO OUTSTR(CVOS(BUFTT[J])&TB);
00810 END;
00820
00830 PROCEDURE PLOTP;
00840 BEGIN
00850 INTEGER J,K,L,DJ;
00860 K←0; RIVECT(0,-100);
00870 WHILE TRUE DO BEGIN "PIN"
00880 J←(BUFTT[KTT] LSH -15)-((SEGC-1)*128);
00890 ⊂ OUTSTR("KTT="&CVS(KTT)&TB&TB&CVS(J)&TB&CVS(SEGC)&CRLF);
00900 IF J<0 THEN
00910 IF KTT<511 THEN BEGIN KTT←KTT+1; CONTINUE "PIN"; END ELSE BEGIN
00920 IF EOFTF≠0 THEN DONE "PIN"; DTTTIN; CONTINUE "PIN"; END;
00930 IF J>128 THEN DONE "PIN" ELSE BEGIN
00940 ⊂ OUTSTR("A pulse mark has been written at J="&CVS(J)&CRLF);
00950 ⊂ OUTSTR("KTT="&CVS(KTT)&TB&TB&CVS(J)&TB&CVS(SEGC)&CRLF);
00960 DJ←J-K; K←J; KTT←KTT+1;
00970 FVAL[FX]←(SEGC-SEGCS)*128+K;
00980 ⊂ OUTSTR(CVS(FVAL[FX])&CRLF);
00990 FX←FX+1;
01000 RIVECT(DJ,0); RVECT(0,30); RVECT(0,-30); END;
01010 END "PIN";
01020 RIVECT(-K,100);
01030 END;
01040
01050
01060 PROCEDURE PLOT;
01070 BEGIN
01080 INTEGER I,JP,K,LP;
01090 PTCNT←PTCNT+1; IF PTCNT≤4 THEN BEGIN
01100 PLOTP;
01110 POINTV←POINTX;
01120 K←LDB(POINTV); IF K>2047 THEN K←K-4096;
01130 K←K%8;
01140
01150 RIVECT(0,K);
01160 FOR I←0 STEP 1 UNTIL 127 DO BEGIN
01170 JP←ILDB(POINTV); IF JP>2047 THEN JP←JP-4096;
01180 D[DX]←JP; DX←DX+1;
01190 ⊃ SETFORMAT(10,3); ⊃ OUTSTR(CVS(I)&TB&CVG(JP)&CRLF);
01200 JP←JP%8;
01210 LP←JP-K; RVECT(1,LP); K←JP; END;
01220 RIVECT(0,-K);
01230 IF PTCNT=4 THEN BEGIN
01240 RIVECT(-200,-130);
01250 IF (SYMBOL[Q] LAND '3777777777)>0 THEN READ←CVSTR(SYMBOL[Q])[1 TO 2] ELSE
01260 READ←CVSTR(SYMBOL[Q])[1 TO 1];
01270 IF OPT1=1 THEN BEGIN
01280 DPYSST(CVXSTR(LFILE[10])[2 TO 3]&" "&READ&" ? "&CVS(JPX));
01290 SETFORMAT(1,0);
01300 IF (J-JPX)<0 THEN DPYSST(CVS(J-JPX)) ELSE DPYSST("+"&CVS(J-JPX));
01310 SETFORMAT(3,0); END;
01320 IF OPT1≠1 THEN
01330 DPYSST(CVXSTR(LFILE[10])[2 TO 3]&" "&READ&" "&CVS(J)&" "&CVS(KK));
01340 RIVECT(20,130); END;
01350 END;END;
01360
01370 PROCEDURE FRIC;
01380 BEGIN
01390 INTEGER JJJ;
01400 ⊂ STATE=0 means on way up
01410 STATE=1 means on way down;
01420 M←0;
01430 PLOT;
01440 FOR JJJ←0 STEP 1 UNTIL 127 DO BEGIN
01450 VAL←ILDB(POINTX); IF VAL>2047 THEN VAL←VAL-4096;
01460 DVAL←VAL-K; DDVAL←DVAL-DK; DDDVAL←DDVAL-DDK;
01470 IF STATE=0 THEN BEGIN
01480 IF DDDVAL<DDDK-DELTA THEN BEGIN
01490 M←M+(DDDK-DDDVAL); STATE←-1; END; END ELSE
01500 IF DDDVAL>DDDK+DELTA THEN BEGIN
01510 M←M+(DDDVAL-DDDK); STATE←0; END;
01520 K←VAL; DK←DVAL;DDK←DDVAL; DDDK←DDDVAL;
01530 IF JJJ=2 THEN M←0;
01540 END;
01550 M←M%400; IF M>63 THEN M←63;
01560 SEGC←SEGC+1;
01570 END;
01580
01590 PROCEDURE DATA;
01600 BEGIN
01610 INTEGER I;
01620 FOR I←0 STEP 1 UNTIL 23 DO BEGIN
01630 DAT[I]←ILDB(POINTT);
01640 AVDAT[I]←AVDAT[I]+DAT[I];
01650 END;
01660 SEGCT←SEGCT+1;
01670 END;
01680
01690 PROCEDURE TYDATT;
01700 BEGIN
01710 INTEGER I,J,K;
01720 K←0;
01730 FOR I←0 STEP 1 UNTIL 23 DO BEGIN
01740 J←ILDB(POINTT);
01750 OUTALL(CVS(J));
01760 END; OUTSTR(CRLF); END;
01770
01780 PROCEDURE SKIP;
01790 BEGIN
01800 INTEGER JJJ;
01810 FOR JJJ←0 STEP 1 UNTIL 127 DO IBP(POINTX);
01820 K←LDB(POINTX); IF K>2047 THEN K←K-4096;
01830 SEGC←SEGC+1;
01840 ⊃ OUTSTR("Skip to segc= "&CVS(SEGC)&CRLF);
01850 END;
01860
01870 PROCEDURE SKIPT;
01880 BEGIN
01890 INTEGER JJJ;
01900 FOR JJJ←0 STEP 1 UNTIL 23 DO IBP(POINTT);
01910 SEGCT←SEGCT+1;
01920 ⊃ OUTSTR("Skip to segct= "&CVS(SEGCT)&CRLF);
01930 END;
01940
01950 PROCEDURE SHUFFLE;
01960 BEGIN "SHUF"
01970 INTEGER I,J,K;
01980
01990 AIVECT(-599,-360);
02000 I←DPYPTR-PT1; ⊂ Words to save;
02010 J←PT1-PT0; ⊂ Words to overwrite;
02020 FOR K←1 STEP 1 UNTIL I DO DPYBUF[K+3]←DPYBUF[K+3+J];
02030 FOR K←I+1 STEP 1 UNTIL J+I DO DPYBUF[K+3]←1;
02040 PT1←DPYPTR←PT0+I;
02050 DPYOUT(0); PTOCHW(0,'10120);
02060 END "SHUF";
02070
02080 PROCEDURE RARDIS;
02090 BEGIN
02100 INTEGER I,J,K,SP;
02110 INTEGER LY,DY;
02120 REAL MAX,MIN;
02130
02140
02150 MAX←-1000.;MIN←10000.;
02160 FOR I←0 STEP 1 UNTIL 256 DO IF C[I]>MAX THEN MAX←C[I];
02170 SP←6; COMMENT HORIZONTAL SPACING;
02180 FOR I←0 STEP 1 UNTIL 256 DO BEGIN
02190 C[I]←5.5*(C[I]+48-MAX); IF C[I]<0 THEN C[I]←0; END;
02200 IF SHUFCT=1 THEN SHUFFLE; SHUFCT←1;
02210
02220
02230 RIVECT(35,130);
02240
02250 SETFORMAT(1,0);
02260 ⊂ Write horizantal numbers;
02270 FOR I←0 STEP 1 UNTIL 5 DO BEGIN
02280 DPYSST(CVS(I)); RIVECT(139,0); END; RIVECT(-139,0);
02290 FOR I←6 STEP 1 UNTIL 10 DO BEGIN
02300 RIVECT(36,0); DPYSST(CVS(I)); END; RIVECT(-22,-5);
02310 RIVECT(-512,0); RIVECT(-512,0);
02320
02330 rivect(-1,0); ⊂ Start with 1 off so total will be correct;
02340 ⊂ Draw scale to 5000, with 50 markers to 770;
02350 FOR I←1 STEP 1 UNTIL 5 DO BEGIN
02360 FOR J←1 STEP 1 UNTIL 2 DO BEGIN
02370 FOR K←1 STEP 1 UNTIL 2 DO BEGIN
02380 RIVECT(15,0); RIVECT(0,-10); RVECT(0,10);
02390 RIVECT(16,0); RIVECT(0,-10); RVECT(0,10); END;
02400 RIVECT(15,0); RIVECT(0,-40); RVECT(0,40); END;
02410 RIVECT(0,-264); RVECT(0,264); END;
02420
02430 ⊂ Draw scale from 5000 to 10,000, with 25 markers to 255;
02440 FOR I←1 STEP 1 UNTIL 5 DO BEGIN
02470 RIVECT(51,0); RVECT(0,-40);
02472 IF I=5 THEN RVECT(0,-114) ELSE RIVECT(0,-114);
02475 RVECT(0,-110);RIVECT(0,264); END;
02480 RVECT(-512,0); RVECT(-512,0);
02490
02500 SETFORMAT(2,0);
02510 ⊂ Vertical numbers and vertical scale;
02520 FOR I←0 STEP 12 UNTIL 42 DO BEGIN
02530 RIVECT(-35,-7); DPYSST(CVS(I)); RIVECT(15,7);
02540 RVECT(-10,0); RIVECT(0,-33);
02550 RIVECT(-35,-7); DPYSST(CVS(I+6)); RIVECT(10,7);
02560 RVECT(-5,0);RIVECT(0,-33); END;
02570 RIVECT(0,264); RVECT(0,-264);
02580 RIVECT(-35,-7); DPYSST(CVS(I)); RIVECT(5,7);
02590 RVECT(512,0); RVECT(512,0); RIVECT(-512,0); RIVECT(-512,0);
02600
02610 LY←C[0]; RIVECT(0,LY);
02620 FOR I←1 STEP 1 UNTIL 128 DO
02630 BEGIN
02640 DY←C[I]-LY;
02650 LY←LY+DY;
02660 RVECT(SP,DY);
02670 END;
02680 SP←2;
02690 FOR I←129 STEP 1 UNTIL 256 DO
02700 BEGIN
02710 DY←C[I]-LY;
02720 LY←LY+DY;
02730 RVECT(SP,DY);
02740 END;
02750 RIVECT(-243,180-LY);
02755 DPYSST(FILEN); RIVECT(-244,-25);
02756 FVAL1←(SEGCS-1)*128+FVAL[FX];FVAL2←(SEGCS-1)*128+FVAL[FX+1];
02757 DPYSST(CVS(FVAL1)&" to "&CVS(FVAL2));
02760 END "RARDIS";
02770
02780 INTERNAL PROCEDURE XRTRAN(REAL ARRAY A,B;INTEGER N,EVALUATE);
02790 BEGIN
02800 COMMENT IF EVALUATE IS FALSE THIS INTERNAL PROCEDURE UNSCRAMBLES THE SINGLE VARIATE
02810 COMPLEX TRANSFORM ;
02820 INTEGER K,NK,NH;
02830 REAL AA,AB,BA,BB,RE,IM,CK,SK,DC,DS,R;
02840 NH←N%2; R←3.1415926536/N;
02850 DS←SIN(R); R←-(2*SIN(0.5*R))↑2;
02860 DC←-0.5*R; CK←1.0; SK←0;
02870 IF EVALUATE THEN
02880 BEGIN
02890 CK←-1.0; DC←-DC;
02900 END
02910 ELSE
02920 BEGIN
02930 A[N]←A[0]; B[N]←B[0];
02940 END;
02950 FOR K←0 STEP 1 UNTIL NH DO
02960 BEGIN
02970 NK←N-K;
02980 AA←A[K]+A[NK]; AB←A[K]-A[NK];
02990 BA←B[K]+B[NK]; BB←B[K]-B[NK];
03000 RE←CK*BA+SK*AB; IM←SK*BA-CK*AB;
03010 B[NK]←IM-BB; B[K]←IM+BB;
03020 A[NK]←AA-RE; A[K]←AA+RE;
03030 DC←R*CK+DC; CK←CK+DC;
03040 DS←R*SK+DS; SK←SK+DS;
03050 END;
03060 END "XRTRAN";
03070
03080 INTERNAL PROCEDURE FORM(INTEGER LPCOPT);
03090 BEGIN "FORM"
03100 REAL ERRN,ERR;
03110 INTEGER I,J,LP,JJP;
03120 M←9; N←2↑M; DEFINE PI="3.141592653";
03130 IF FX=0 THEN
03140 FOR I←0 STEP 1 UNTIL N DO WINDOW[I]←(1-COS((2*PI*I)/N))/2
03150
03160 ELSE BEGIN N←FVAL[FX+1]-FVAL[FX]; J←0;
03170 FOR I←0 STEP 1 UNTIL FVAL[FX] DO WINDOW[I]←0;
03180 FOR I←FVAL[FX] STEP 1 UNTIL FVAL[FX+1] DO BEGIN
03190 WINDOW[I]←(1-COS((2*PI*J)/N))/2; J←J+1; END;
03200 FOR I←FVAL[FX+1] STEP 1 UNTIL 512 DO WINDOW[I]←0; END;
03210 FOR I←0 STEP 1 UNTIL 512 DO A[I]←D[I];
03211 IF WFLAG=1 THEN BEGIN
03212 AIVECT(-569,270);K←WINDOW[0]*150; RIVECT(0,K);
03213 FOR I←1 STEP 1 UNTIL 350 DO BEGIN
03214 JJP←WINDOW[I]*150;
03215 LP←JJP-K; RVECT(3,LP); K←JJP; END;
03216 RIVECT(-550,-K); RIVECT(-500,0);AIVECT(-599,-360);
03217 DPYOUT(0);END;
03218
03230 IF LPCOPT=0 THEN BEGIN "LPC"
03240 FOR I←0 STEP 1 UNTIL N-2 DO A[I]←(A[I+1]-A[I])*WINDOW[I];
03250 ⊂ LOADS DATA IN A, DIFFERENTIATES AND WINDOWS ;
03260 I←24; J←N%2;
03270 ⊂ LPC1(A[0],B[0],R0,C[0],N,I,J);
03280 END "LPC" ELSE
03290
03300 BEGIN "FFT"
03310 FOR I←0 STEP 1 UNTIL 512 DO BEGIN
03320 A[I]←D[I]*WINDOW[I]; B[I]←0;
03330 ⊃ SETFORMAT(10,3); ⊃ OUTSTR(CVS(I)&TB&CVG(D[I])&TB&CVG(A[I])&CRLF);
03340 END;
03341 IF WFLAG=1 THEN BEGIN
03342 AIVECT(-569,270);K←A[0]%8; RIVECT(0,K);
03343 FOR I←1 STEP 1 UNTIL 350 DO BEGIN
03344 JJP←A[I]%8;
03345 LP←JJP-K; RVECT(3,LP); K←JJP; END;
03346 RIVECT(-550,-K); RIVECT(-500,0);AIVECT(-599,-360);
03347 DPYOUT(0); END;
03348
03350 FRXFM(M,A[0],B[0]);
03360 ⊃ OUTSTR("FFT COMPLETE"&CRLF);
03370 FOR I←0 STEP 1 UNTIL 256 DO BEGIN
03380 X←(A[I]↑2)+(B[I]↑2)+1.*(10↑-37);
03390 ⊃ OUTSTR(CVG(A[I])&" "&CVG(B[I])&" "&CVG(X)&TB);
03400 C[I]←10.*ALOG10(X); END;
03410 END "FFT";
03420
03430 RARDIS;
03440 END "FORM";
03450
03460 PROCEDURE MARK;
03470 BEGIN
03480 INTEGER I,JJ,K,L,JJP,LP,PT2;
03490
03500 PTOCHW(0,'14127); ⊂ Makes the WHQ line go away;
03510 IF SHUFCT=1 THEN BEGIN SHUFCT←0; SHUFFLE; END;
03520 TYPLOC(512,430); AIVECT(-599,270);
03530 RIVECT(0,-130); SETFORMAT(3,0);
03540 FOR I←0 STEP 20 UNTIL 340 DO BEGIN
03550 DPYSST(CVS(I)); RIVECT(15,0); END;
03560 RIVECT(-555,30); RIVECT(-500,0);
03570
03580 FOR I←0 STEP 100 UNTIL 300 DO BEGIN "HUNDRED"
03590 RIVECT(0,30); RVECT(0,-30);
03600 FOR JJ←0 STEP 50 UNTIL 50 DO BEGIN "FIFTY"
03610 FOR K←1 STEP 1 UNTIL 5 DO BEGIN "TEN"
03620 RIVECT(15,0); RVECT(0,5); RIVECT(0,-5);
03630 RIVECT(15,0); RVECT(0,10);RIVECT(0,-10);
03640 END "TEN";
03650 RVECT(0,20); RIVECT(0,-20);
03660 IF I≥300 THEN DONE "HUNDRED";
03670 END "FIFTY";
03680 END "HUNDRED";
03690 RIVECT(-550,100); RIVECT(-500,0);
03700
03710 K←D[0]%8; RIVECT(0,K);
03720 FOR I←1 STEP 1 UNTIL 350 DO BEGIN
03730 JJP←D[I]%8;
03740 LP←JJP-K; RVECT(3,LP); K←JJP; END;
03750 RIVECT(-550,-K); RIVECT(-500,0);
03760
03770 PT2←DPYPTR; READ1←"NO"; CLRBUF;
03780
03785 WFLAG←0;
03790 FOR I←1 STEP 1 UNTIL 2 DO BEGIN
03800 WHILE TRUE DO BEGIN
03810 IF READ1≠"" THEN BEGIN DPYPTR←PT2;
03820 RIVECT(500,0);
03830 FOR JJ←1 STEP 1 UNTIL 2 DO BEGIN
03840 L←3*FVAL[JJ]-500;
03850 RIVECT(L,100); RVECT(0,-100); RIVECT(-25,0); RVECT(50,0);
03860 RIVECT(-25,0); RVECT(0,-100); RIVECT(-L,100); END;
03870 RIVECT(-500,0);
03880 DPYOUT(0); END;
03885 OUTSTR("W and CR now will cause window info to appear later"&CRLF);
03890 IF FVAL[I]=0 THEN OUTSTR("Specify position of marker #"&
03900 CVS(I)&" ") ELSE OUTSTR("Move marker #"&CVS(I)&" (CR if OK) ");
03910 IF (READ1←INCHWL)="" THEN DONE;
03915 IF (READ1="W")∨(READ1="w") THEN WFLAG←1 ELSE
03920 FVAL[I]←FVAL[I]+CVD(READ1);
03930 END; END;
03940
03950 FVAL1←(J-1)*128+FVAL[1];
03960 OUTSTR("Markers at samples "&CVS(FVAL1)&" and ");
03965 FVAL2←(J-1)*128+FVAL[2];
03966 OUTSTR(CVS(FVAL2)&". ");
03970
03980 AIVECT(-599,-360); PT1←DPYPTR; FX←1; FORM(1);
03990
04017 READ1←"M"; ⊂ Replace for use by if statement above;
04020
04030 END;
04040
04050 INTERNAL PROCEDURE CALCOMP(STRING FILE;INTEGER ARRAY BUFR);
04060 ⊃ Outputs display buffer BUFR to disk file FILE in a format
04070 readable by the Nealy Calcomp plotter program PLTVEC, and by
04080 the Quam Video Synthesizer program MIRTOP;
04090 IF FILE THEN
04100 BEGIN INTEGER DSIZ,CCCHN;
04110 OPEN(CCCHN←GETCHAN,"DSK",'14,0,1,0,0,0);
04120 ENTER(CCCHN,FILE&".GRF",0);
04130 OUTSTR("READY TO DPYPARS");
04140 DPYPARS;DSIZ←BUFR[1]+4;
04150 OUTSTR("BACK FROM DPYPARS"&CRLF);
04160 ARRYOUT(CCCHN,BUFR[0],2);WORDOUT(CCCHN,0);
04170 ARRYOUT(CCCHN,BUFR[2],DSIZ-2);
04180 RELEASE(CCCHN);
04190 END "CALCOMP";
00010 DPYSET(DPYBUF); AIVECT(-599,-70); PT0←DPYPTR;
00020 SHUFCT←0;AIVECT(-599,-360);PT1←DPYPTR;
00030 FILEN←"HI20.001[CMP,JH]";
00040 FILEO←"SEG1.FRI";
00050 ⊂ HEADIN;
00060 STDBRK(1);
00070 SETBREAK(14,"∃",NULL,"INS");
00080 SETBREAK(15,'11&'12&'14&'15&'40,NULL,"INS");
00090 SETBREAK(16,'56,NULL,"INA");
00100 SETBREAK(17,'12,'15,"INS");
00110
00120 CHAN1←1; CHAN2←2; CHAN3←3; CHAN4←4; CHAN5←5; CHAN6←6;
00130 OUTSTR("This program shows header information and wave forms for selected "
00140 &" phones."&crlf&LF);
00150 OUTSTR("At present this program takes acoustic data from [CMP,JH],"&
00160 CRLF&tb&"indentifying information from MAP.PHM[11,ALS]"&CRLF&
00170 TB&"pulse informstion from .P[PIT,NJM] files"&CRLF&TB&
00180 "and header information from files .T0X[11,ALS]."&CRLF&LF);
00190 OUTSTR("After a display it accepts the following commands"&CRLF&TB&
00200 "Space bar - go to the next phone"&CRLF&TB&
00210 "S - start over"&CRLF&TB&
00220 "E - exit from program"&CRLF&TB&
00230 "a number - shift by specified # of 6.4 ms intervals"&CRLF&TB&
00240 "line feed - next phone from a forward shifted location"&CRLF&TB&
00250 "F & CR - 512 point FFT"&CRLF&TB&
00260 "F & # - interval FFT starting st marker number #"&CRLF&TB&
00270 "M - go to movable marker mode"&crlf&TB&
00280 "P - prepare file for an XGP plot of screen"&CRLF&TB&
00290 "W - write DPYBUF to clear plot"&CRLF&LF);
00300
00310 CLOSE(CHAN4); OPEN(CHAN4,"DSK",1,2,0,3500,BRK,EOFA);
00320 LOOKUP(CHAN4,"MAP.PHN[11,ALS]",ER);
00330 WHILE ER DO BEGIN OUTSTR(CRLF&"Can't find MAP.PHN[11,ALS]. File = ");
00340 LOOKUP(CHAN4,TFILE←INCHWL,ER); END; EOFA←0;
00350 FILLST←INPUT(CHAN4,14);
00360 CLOSE(CHAN4);
00370
00380 FOR I←0 STEP 1 UNTIL 127 DO BEGIN
00390 WHILE TRUE DO BEGIN
00400 READ1←SCAN(FILLST,17,K);
00410 READ3←READ1[1 TO 1];
00420 IF READ3≠"⊂" THEN DONE; END;
00430 IF READ3="" THEN DONE;
00440 SYMBOL[I]←CVASC(SCAN(READ1,15,K));
00450 SAMPLE[I]←READ1; END;
00460
00470 STARTP:
00480 WHILE TRUE DO BEGIN "PICK"
00490 OUTSTR("Select PH (CR only for everything) ");
00500 IF (READ←INCHWL)="" THEN DONE ELSE BEGIN PICK←CVASC(READ);
00510 FOR Q←0 STEP 1 UNTIL 127 DO IF PICK=SYMBOL[Q] THEN DONE;
00520 IF Q<128 THEN DONE;
00530 OUTSTR("Not found"&crlf); END; END "PICK";
00540
00550 OUTSTR(CRLF&"You have selected "&tb);
00560 IF READ="" THEN BEGIN OPT←0; OUTSTR("Everything"&crlf); END ELSE BEGIN
00570 OUTALL(CVSTR(PICK)&TB&SAMPLE[Q]&CRLF&" "); OPT←1; END;
00580 DELTA←15;
00590 ⊂ OUTSTR("Specify DELTA (CR for 15) ");
00600 ⊂ IF (READ←INCHWL)="" THEN DELTA←15 ELSE DELTA←CVD(READ);
00610
00620 OUTSTR(CRLF&"Type number of file to start (CR only for 1) ");
00630 IF (READ←INCHWL)="" THEN PP←1 ELSE PP←CVD(READ);
00640 TYPLOC(512,100);
00650 FOR PP←PP STEP 1 UNTIL 26 DO BEGIN "FILEREAD"
00660 CLOSE(CHAN1); OPEN(CHAN1,"DSK",'10,10,0,0,0,EOF);
00670 SETFORMAT(-3,0); FILEQ←CVS(PP);
00680 FILEN←FILEN[1 TO 5]&FILEQ&"[CMP,JH]";
00690 LOOKUP(CHAN1,FILEN,ER); TFILE←FILEN;
00700 WHILE ER DO BEGIN
00710 IF PP>1 THEN BEGIN OUTSTR("Out of data, will start over."&CRLF);
00720 GOTO STARTP; END;
00730 OUTSTR(CRLF&"Can not find file "&TFILE&" File= ");
00740 LOOKUP(CHAN1,TFILE←INCHWL,ER); END;
00750 J←K←L←STATE←VAL←R←0;
00760 SETFORMAT(1,0); FILEQ←CVS(PP);
00770
00780 READT←FILEO[1 TO 3]&FILEQ&".T0X[11,ALS]";
00790 CLOSE(CHAN2); OPEN(CHAN2,"DSK",'10,10,0,0,0,EOFA);
00800 LOOKUP(CHAN2,READT,ER); TFILE←READT;
00810 WHILE ER DO BEGIN
00820 IF PP>1 THEN BEGIN OUTSTR("Out of data, will start over."&CRLF);
00830 GOTO STARTP; END;
00840 OUTSTR(CRLF&"Can not find file "&TFILE&" File= ");
00850 LOOKUP(CHAN2,TFILE←INCHWL,ER); END;
00860 ARRYIN(CHAN2,LFILE[0],'200); ⊂ Input header;
00870 SEGTOT←(LFILE[0]*6)%256;
00880 ⊃ OUTSTR(FILEI&" "&CVS(SEGTOT)&" ");
00890
00900 READ2←READT;
00910 READTT←SCAN(READ2,16,J)&"P[PIT,NJM]";
00920 ⊂ OUTSTR(READTT&CRLF);
00930 CLOSE(CHAN3); OPEN(CHAN3,"DSK",'10,10,0,0,0,EOFT);
00940 LOOKUP(CHAN3,READTT,ER); TFILE←READTT;
00950 ITT←JTT←-1000;KTT←0;
00960 IF ER THEN BEGIN
00970 OUTSTR("No .P data (S to start over, space bar to ignore) ");
00980 IF (READ1←INCHRW)="S" THEN GOTO STARTP ELSE BEGIN
00990 BUFTT[0]←'77777; BUFTT[1]←'377777700000;ITT←0; JTT←'3777777;
01000 CLRBUF; END; END;
01010
01020 II←-11; JJ←-1; IIT←-127; JJT←-1; SETFORMAT(3,0); SEGIN←0;
01030
01040 ⊂ Begin "SELECT";
01050
01060 FOR I←21 STEP 1 UNTIL 127 DO BEGIN "SELECT"
01070 IF LFILE[I]=0 THEN IF I>0 THEN DONE ELSE BEGIN
01080 OUTSTR("No data."&crlf); done end;
01090 L←LFILE[I] LAND '777760000000;
01100
01110 ⊂ Begin "FOUND";
01120
01130 IF (OPT=0) ∨ (L=PICK) THEN BEGIN "FOUND"
01140 FOR Q←0 STEP 1 UNTIL 126 DO IF L=SYMBOL[Q] THEN DONE;
01150 JPX←J←LDB(POINT(14,LFILE[I],27)); KK←LDB(POINT(8,LFILE[I],35));
01160
01170 ⊂ Begin "GET";
01180
01190 WHILE TRUE DO BEGIN "GET"
01200
01210 SEGCS←J; FX←1;
01220 IF KK<4 THEN PTCNT←4-KK ELSE PTCNT←0;
01230
01240 IF II>J THEN BEGIN
01250 IF (READ1='12) THEN CONTINUE "SELECT";
01260 CLOSE(CHAN1); OPEN(CHAN1,"DSK",'10,10,0,0,0,EOF);
01270 LOOKUP(CHAN1,FILEN,ER); TFILE←FILEN;
01280 WHILE ER DO BEGIN
01290 OUTSTR(CRLF&"Can not find file "&TFILE&" File= ");
01300 LOOKUP(CHAN1,TFILE←INCHWL,ER); END;
01310 II←-11; JJ←-1;
01320 END;
01330
01340 IF IIT>J THEN BEGIN
01350 IF (READ1='12) THEN CONTINUE "SELECT";
01360 CLOSE(CHAN2); OPEN(CHAN2,"DSK",'10,10,0,0,0,EOFA);
01370 LOOKUP(CHAN2,READT,ER); TFILE←READT;
01380 WHILE ER DO BEGIN
01390 OUTSTR(CRLF&"Can not find file "&TFILE&" File= ");
01400 LOOKUP(CHAN2,TFILE←INCHWL,ER); END;
01410 ARRYIN(CHAN2,LFILE[0],'200); ⊂ Input header;
01420 IIT←-127; JJT←-1;
01430 END;
01440
01450 ⊂ OUTSTR("ITT="&CVS(ITT)&TB&"J="&CVS(J)&CRLF);
01460 IF ITT>J*128 THEN BEGIN
01470 IF (READ1='12) THEN CONTINUE "SELECT";
01480 CLOSE(CHAN3); OPEN(CHAN3,"DSK",'10,10,0,0,0,EOFT);
01490 LOOKUP(CHAN3,READTT,ER); TFILE←READTT;
01500 WHILE ER DO BEGIN
01510 OUTSTR(CRLF&"Can not find file "&TFILE&" File= ");
01520 LOOKUP(CHAN3,TFILE←INCHWL,ER); END;
01530 ITT←JTT←-1000; KTT←0;
01540 END;
01550
01560 ⊂ OUTSTR("JTT="&CVS(JTT)&TB&"J="&CVS(J)&CRLF);
01570 WHILE JJ<J DO DATAIN; WHILE JJT<J DO DATTIN;
01580 ⊂ OUTSTR("JJ="&CVS(JTT)&TB&"J="&CVS(J)&"before DTTTIN");
01590 WHILE JTT<(J-1)*128 DO DTTTIN;
01600 ⊂ OUTSTR(" and after JTT="&CVS(JTT)&CRLF);
01610
01620
01630 IF SEGC>J THEN BEGIN
01640 POINTX←POINT(12,BUF[0],-1);
01650 SEGC←II; JJ←II+11; END;
01660
01670 IF SEGCT>J THEN BEGIN
01680 POINTT←POINT(6,BUFT[0],-1);
01690 SEGCT←IIT; JJT←IIT+127; END;
01700
01710 ⊂ OUTSTR("KTT="&CVS(KTT)&TB&"BUFTT[KTT] LSH -15="&CVS(BUFTT[KTT] LSH -15)&TB&"J="&CVS(J)&CRLF);
01720 WHILE (BUFTT[KTT] LSH -15)>(J-1)*128 DO BEGIN
01730 IF KTT=0 THEN DONE; KTT←KTT-1; END;
01740
01750 WHILE SEGC<J DO SKIP; WHILE SEGCT<J DO SKIPT;
01760
01770 IF SHUFCT=0 THEN BEGIN
01780 OUTSTR(
01790 " F1 F3 A2 FP1 FP2 FZ NP NZ LPE HPE HPA PIT"
01800 &CRLF&
01810 " F2 A1 A3 FP1A FP2A FZA NPA NZA AVE LPA FRI FRI4"
01820 &CRLF); END;
01830
01840 FOR QQ←0 STEP 1 UNTIL 7 DO FVAL[QQ]←0;
01850 FOR DX←0 STEP 1 UNTIL 512 DO D[DX]←0; DX←0;
01860 SETFORMAT(3,0);
01870 IF OPT1=1 THEN FOR QQ←1 STEP 1 UNTIL 4 DO BEGIN
01880 IF SEGC>JJ THEN DATAIN; IF SEGCT>JJT THEN DATTIN;
01890 FRIC;
01900 DATA; DAT[23]←M;
01910 OUTSTR(CVS(QQ)&" ");
01920 FOR K←0 STEP 1 UNTIL 23 DO OUTSTR(CVS(DAT[K])); OUTSTR(CRLF);
01930 END ELSE BEGIN
01940 FRIC;
01950 FOR K←0 STEP 1 UNTIL 23 DO AVDAT[K]←0;
01960 DATA; DAT[23]←M;
01970
01980 OUTSTR(" F ");
01990 FOR K←0 STEP 1 UNTIL 23 DO OUTSTR(CVS(DAT[K])); OUTSTR(CRLF);
02000 N←M;
02010
02020 FOR R←2 STEP 1 UNTIL KK DO BEGIN
02030 IF SEGC>JJ THEN DATAIN;
02040 IF SEGCT>JJT THEN DATTIN;
02050 FRIC; N←N+M; DATA; END;
02060 DAT[23]←M; AVDAT[23]←N;
02070 OUTSTR(" A ");
02080 FOR K←0 STEP 1 UNTIL 23 DO BEGIN
02090 AVDAT[K]←AVDAT[K]%KK; OUTSTR(CVS(AVDAT[K])); END; OUTSTR(CRLF);
02100 OUTSTR(" L ");
02110 FOR K←0 STEP 1 UNTIL 23 DO OUTSTR(CVS(DAT[K])); OUTSTR(CRLF);
02120 END;
02130
02140 OUTSTR("space to cont., F for FFT, M for mode, "&
02150 "# to shift, S to start, W to write."&crlf);
02160
02170
02180 ⊂ Begin "SHOW";
02190
02200 WHILE TRUE DO BEGIN "SHOW"
02210 DPYOUT(0);PTOCHW(0,'10120); PTCNT←0;
02215 IF READ1="M" THEN BEGIN CLRBUF;
02217 OUTSTR("Type P for XGP copy file or type next command."); END;
02220
02230 FOR QQ←4 STEP 1 UNTIL 4095 DO IF DPYBUF[QQ] =1 THEN DONE;
02240 ⊂ OUTSTR("DPYBUF filled to "&CVS(QQ)&CRLF);
02250
02260 READ1←INCHRW;
02270 WHILE (READ1="W")∨(READ1="w") DO BEGIN DPYOUT(0) ;
02280 PTOCHW(0,'10120);READ1←INCHRW; END;
02290 IF (READ1="P")∨(READ1="p") THEN BEGIN CALCOMP("PLOTX",DPYBUF);
02300 OUTSTR("EX DPYXGP[X,ALS] plots PLOTX.GRF on the XGP. Next command please."&CRLF);
02310 READ1←INCHRW; END;
02320 IF (READ1≠"M")∧(READ1≠"F")∧(READ1≠"m")∧(READ1≠"f") THEN BEGIN
02330 TYPLOC(512,100); PTOCHW(0,'10103); PTOCHW(0,'10120); END;
02340 SHUFCT←SHUFCT+1; IF SHUFCT<2 THEN RIVECT(20,0)
02350 ELSE BEGIN SHUFCT←0; SHUFFLE; END;
02360 K←CVASC(READ1); OPT1←0;
02370
02380 IF K≥CVASC("+") THEN IF K≤CVASC("9") THEN BEGIN
02390 JP←CVD(READ1&INCHWL); OPT1←1; KK←4; IF JP<(-J) THEN JP←(-J);
02400 JP↔J; J←J+JP; CONTINUE "GET"; END;
02410 OUTSTR(CR);
02420 IF READ1=" " THEN CONTINUE "SELECT";
02430 IF (READ1='15)∨(READ1='12) THEN BEGIN
02440 CLRBUF; CONTINUE "SELECT"; END;
02450 TOFORM:
02460 IF (READ1="F")∨(READ1="f") THEN BEGIN
02470 IF (READ1←INCHWL)="" THEN BEGIN FX←0; FVAL[0]←0;FVAL[1]←512;END
02475 ELSE FX←CVD(READ1);
02480 FORM(1); CLRBUF; END;
02490 IF (READ1="L")∨(READ1="l") THEN BEGIN FORM(0); CLRBUF; END;
02500 IF (READ1="M")∨(READ1="m") THEN MARK;
02510 IF (READ1="S")∨(READ1="s") THEN BEGIN
02520 OUTSTR(LF&"You are starting over"&CRLF); CLRBUF;
02530 GOTO STARTP; END;
02540 IF (READ1="E")∨(READ1="e") THEN GOTO STOPP;
02550 END "SHOW";
02560 END "GET";
02570 END "FOUND";
02580 END "SELECT";
02590 END "FILEREAD";
02600
02610 OUTSTR("Data are exhausted"&CRLF&LF); GOTO STARTP;
02620 STOPP: PTOCHW(0,'10103); PTOCHW(0,'10120);
02630
02640 END "PLOT";
02650